;;;; Copyright 2009 Peter von Etter

;;;; This file is part of Autoproject

;;;; Autoproject is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation, either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; Autoproject is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with Autoproject.  If not, see
;;;; <http://www.gnu.org/licenses/>.

(in-package :autoproject)

(define-condition failed-compilation () 
  ((failed-system :initarg :failed-system)))

(defun asdf-system-dependencies (system)
  (cdr (assoc 'asdf:load-op
              (asdf:component-depends-on
               'asdf:load-op (asdf:find-system system)))))

(defun asdf-system-dependency-tree (system)
  (cons system 
        (mapcar 'asdf-system-dependency-tree 
                (asdf-system-dependencies system))))

(defun load-asdf-system-dependencies (system)
  (let ((deps (asdf-system-dependencies system)))
    (mapc (lambda (x)
            (asdf:operate 'asdf:load-op x))
          deps)))

(labels ((exec-with-autoproject (form)
           (asdf:run-shell-command
            (make-lisp-shell-command 
             :eval `((require ,*this-package*)
                     ,form
                     (quit))
             :batch t)))
         
         (tree-preorder (tree)
           (when tree
             (destructuring-bind (system &rest deps) tree
               (let ((d (mapcar #'tree-preorder deps)))
                 (append (apply #'append d) (list system))))))

         (apply-tree-preorder (tree fn)
           (destructuring-bind (system &rest deps) tree
             (mapcar #'(lambda (x)
                         (apply-tree-preorder x fn))
                     deps)
             (funcall fn system)))

         (make-compiler-fn (f)
           (let ((seen-systems))
             (lambda (x)
               (setf x (string-downcase x))
               (unless (find x seen-systems :test #'equal)
                 (push x seen-systems)
                 (funcall f x)))))

         (exec-incrementally (system f)
           (let ((deps-tree (asdf-system-dependency-tree system)))
             (apply-tree-preorder 
              deps-tree
              (make-compiler-fn f))))
         
         (quiet-compile (f)
           (let ((*compile-print* nil)
                 (*compile-verbose* nil))
             (funcall f)))

         (default-compile (f)
           (funcall f))

         (choose-compile-loudness (method f)
           (case method
             (:quiet (quiet-compile f))
             (t (default-compile f)))))

  (defun asdf-module-latest-timestamp (component)
    (typecase component
      (asdf:source-file 
       (file-write-date
        (car 
         (asdf:input-files
          (make-instance 'asdf:compile-op) component))))
      (t (or (loop :for i :in (asdf:module-components component)
                   :maximize (asdf-module-latest-timestamp i))
             0)))) 
  
  (defun compile-asdf-system (system-name &key (compile-loudness *compile-loudness*))
    (choose-compile-loudness
     compile-loudness
     (lambda ()
       (asdf:oos 'asdf:load-op system-name))))

  (defun recompile-asdf-system (system-name &key (compile-loudness *compile-loudness*))
    (choose-compile-loudness
     compile-loudness
     (lambda ()
       (handler-case 
           (asdf:oos 'asdfa:revert-op system-name)
         (file-error () (warn "Could not revert system ~A" 
                              system-name))) 
       (asdf:oos 'asdf:load-op system-name))))

  (defun exec-recompile-asdf-system (system &key (compile-loudness *compile-loudness*))
    (let ((asdf::*verbose-out* *standard-output*))
      (choose-compile-loudness 
       compile-loudness
       (lambda ()
         (exec-with-autoproject
          `(recompile-asdf-system 
            ,(string-downcase system)
            :compile-loudness ,compile-loudness))))))
  
  (defun exec-compile-asdf-system (system &key (compile-loudness *compile-loudness*))
    (let ((asdf::*verbose-out* *standard-output*))
      (choose-compile-loudness 
       compile-loudness
       (lambda ()
         (exec-with-autoproject
          `(compile-asdf-system 
            ,(string-downcase system)
            :compile-loudness ,compile-loudness))))))

  ;; Todo: combine these somehow

  (defun compile-asdf-system-incrementally (system)
    (let ((status 0))
      (handler-case 
          (exec-incrementally 
           system (lambda (x)
                    (format *error-output* "Compiling ~A~%" x)
                    (let* ((status (exec-compile-asdf-system x)))
                      (when (not (= 0 status))
                        (format *error-output* " ... FAILED~%")
                        (error 'failed-compilation
                               :failed-system system)))))                 
        (failed-compilation () (setf status 1)))
      status))
  
  (defun recompile-asdf-system-incrementally (system)
    (let ((status 0))
      (handler-case 
          (exec-incrementally 
           system (lambda (x)
                    (format *error-output* "Recompiling ~A~%" x)
                    (let* ((status (exec-recompile-asdf-system x)))
                      (when (not (= 0 status))
                        (format *error-output* " ... FAILED~%")
                        (error 'failed-compilation
                               :failed-system system)))))
        (failed-compilation () (setf status 1)))
      status)))
